home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / facilis2.arc / FACILIS.PAS < prev    next >
Pascal/Delphi Source File  |  1991-04-28  |  26KB  |  935 lines
  1. { Facilis 0.31                                      file: FACILIS.PAS    }
  2. {$R+}
  3. program Facilis;
  4.  
  5.  { based on the Pascal S compiler of Niklaus Wirth,
  6.       as modified by R.E. Berry }
  7.  
  8.  { adapted for the IBMPC by John R. Naleszkiewicz }
  9.  
  10.  { extensions by Anthony M. Marcy }
  11.  
  12. const
  13.   version = 0.31;
  14.   nkw  =  35;     { no. of key words }
  15.   alng =  10;     { no. of significant chars in identifiers }
  16.   llng = 121;     { input line legnth }
  17.   emax =  38;     { max exponent of real numbers }
  18.   emin = -38;     { min exponent }
  19.   kmax =  11;     { max no. of significant digits }
  20.   tmax = 300;     { size of symbol table }
  21.   bmax =  30;     { size of block-table }
  22.   amax =  30;     { size of array-table }
  23.   c2max=  50;     { size of real constant table }
  24.   csmax=  30;     { max no. of cases }
  25.   cmax =8000;     { size of code }
  26.   lmax =   7;     { maximum level }
  27.   ermax=  61;     { max error no. }
  28.   omax =  255;    { highest order code }
  29.   xmax =  32767;  { maximum array bound }
  30.   nmax =  32767;  { maximum integer }
  31.   lineleng  =   80; {output line length }
  32.   stacksize = 2000;
  33.  
  34. type
  35.   symbol =
  36.    (intcon,realcon,charcon,stringcon,
  37.     notsy,plus,minus,times,idiv,rdiv,imod,andsy,orsy,insy,
  38.     eql,neq,gtr,geq,lss,leq,
  39.     lparent,rparent,lbrack,rbrack,comma,semicolon,period,twodots,
  40.     colon,becomes,constsy,typesy,varsy,funcsy,nilsy,
  41.     procsy,filesy,arraysy,recordsy,packedsy,setsy,programsy,labelsy,ident,
  42.     withsy,beginsy,ifsy,casesy,repeatsy,whilesy,forsy,gotosy,
  43.     endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,thensy);
  44.  
  45.   index  = -xmax..+xmax;
  46.   alfa   = array [1..alng] of char;
  47.   object = (konstant,vvariable,type1,prozedure,funktion);
  48.   types  = (notyp,ints,reals,bools,chars,strngs,arrays,records);
  49.   symset = set of symbol;
  50.   typset = set of types;
  51.   strng  = string[20];
  52.   order  = record
  53.              f: 0..omax;
  54.              x: 0..lmax;
  55.              y: integer;
  56.            end ;
  57.  
  58. var
  59.   ch    : char;            { last character read from source program}
  60.   rnum  : real;            { real number from insymbol }
  61.   i,j   : integer;
  62.   inum  : integer;         { integer from insymbol }
  63.   sleng : integer;         { string length }
  64.   cc    : integer;         { character counter }
  65.   lc    : integer;         { program location counter }
  66.   ll    : integer;         { length of current line }
  67.   errpos: integer;
  68.   nul   : integer;         { seg of null string }
  69.   t,a,b,c1,c2: integer; { indices to tables}
  70.   skipflag, stackdump, prtables   : boolean;
  71.  
  72.   sy      : symbol;        { last symbol read by insymbol }
  73.   errs    : set of 0..ermax;
  74.   id      : alfa;          { identifier from insymbol }
  75.   progname: alfa;
  76.   stantyps: typset;
  77.   constbegsys,typebegsys,blockbegsys,facbegsys,statbegsys: symset;
  78.  
  79.   line       : array [1..llng] of char;
  80.   key        : array [1..nkw] of alfa;
  81.   ksy        : array [1..nkw] of symbol;
  82.   sps        : array ['!'..'~'] of symbol;
  83.   display    : array [0 .. lmax] of integer;
  84.  
  85.   tab:     array [0 .. tmax] of     { identifier table }
  86.              record
  87.                name: alfa;        link: index;
  88.                obj : object;       typ: types;
  89.                ref : index;     normal: boolean;
  90.                lev : 0 .. lmax;    adr: integer
  91.              end ;
  92.  
  93.   atab:    array [1 .. amax] of     { array-table }
  94.              record
  95.                inxtyp, eltyp: types;
  96.                elref, low, high, elsize, size: index
  97.              end ;
  98.  
  99.   btab:    array [1 .. bmax] of     { block-table }
  100.              record
  101.                last, lastpar, psize, vsize: index
  102.              end ;
  103.  
  104.   spnt,tpnt: ^char;
  105.   rconst:  array [1 .. c2max] of real;
  106.  
  107.   code  :  array [0 .. cmax] of order;
  108.   opcode: byte;
  109.        x: byte;      { operand }
  110.        y: integer;   { operand }
  111.       pc: integer;   { program counter }
  112.  
  113.   psin, psout, prr, prd: text;
  114.  
  115. procedure errormsg;
  116.  
  117. var    k: integer;
  118.      msg: array [0..ermax] of alfa;
  119.      begin
  120.        msg[ 0] := 'undef id  '; msg[ 1] :='multi def ';
  121.        msg[ 2] := 'identifier'; msg[ 3] :='program   ';
  122.        msg[ 4] := ')         '; msg[ 5] :=':         ';
  123.        msg[ 6] := 'syntax    '; msg[ 7] :='ident, var';
  124.        msg[ 8] := 'of        '; msg[ 9] :='(         ';
  125.        msg[10] := 'type      '; msg[11] :='[         ';
  126.        msg[12] := ']         '; msg[13] :='..        ';
  127.        msg[14] := ';         '; msg[15] :='func. type';
  128.        msg[16] := '=         '; msg[17] :='boolean   ';
  129.        msg[18] := 'convar typ'; msg[19] :='type      ';
  130.        msg[20] := '          '; msg[21] :='too big   ';
  131.        msg[22] := '.         '; msg[23] :='typ (case)';
  132.        msg[24] := 'character '; msg[25] :='const id  ';
  133.        msg[26] := 'index type'; msg[27] :='indexbound';
  134.        msg[28] := 'no array  '; msg[29] :='type id   ';
  135.        msg[30] := 'undef type'; msg[31] :='no record ';
  136.        msg[32] := 'boole type'; msg[33] :='arith type';
  137.        msg[34] := 'integer   '; msg[35] :='types     ';
  138.        msg[36] := 'param type'; msg[37] :='variab id ';
  139.        msg[38] := 'string    '; msg[39] :='no.of pars';
  140.        msg[40] := 'bad number'; msg[41] :='type      ';
  141.        msg[42] := 'real type '; msg[43] :='integer   ';
  142.        msg[44] := 'var, const'; msg[45] :='var, proc ';
  143.        msg[46] := 'types (:=)'; msg[47] :='typ (case)';
  144.        msg[48] := 'type      '; msg[49] :='          ';
  145.        msg[50] := 'constant  '; msg[51] :=':=        ';
  146.        msg[52] := 'then      '; msg[53] :='until     ';
  147.        msg[54] := 'do        '; msg[55] :='to downto ';
  148.        msg[56] := 'begin     '; msg[57] :='end       ';
  149.        msg[58] := 'factor    '; msg[59] :='comma     ';
  150.        msg[60] := 'idx string'; msg[61] :='too big   ';
  151.  
  152.        writeln(psout); writeln(psout,' key words');
  153.        k:=0;
  154.        while errs <> [] do begin
  155.          while not (k in errs) do k := k+1;
  156.          writeln(psout,k,'  ',msg[k]);
  157.          errs := errs - [k]
  158.        end
  159.      end { errormsg } ;
  160.  
  161. procedure fatal(n: integer);
  162.  
  163. var    msg: array [1..8] of alfa;
  164. begin
  165.   writeln(psout); errormsg;
  166.  
  167.   msg[ 1] := 'identifier'; msg[ 2] := 'procedures';
  168.   msg[ 3] := 'reals     '; msg[ 4] := 'arrays    ';
  169.   msg[ 5] := 'levels    '; msg[ 6] := 'code      ';
  170.   msg[ 7] := 'strings   '; msg[ 8] := 'input line';
  171.  
  172.   writeln(psout,' compiler table for ', msg[n], ' is too small');
  173.   close(psout); halt       {terminate compilation}
  174. end { fatal } ;
  175.  
  176. function stupcase(st: strng): strng;
  177.  
  178. var i: integer;
  179.  
  180. begin
  181.   for i := 1 to length(st) do
  182.     st[i] := upcase(st[i]);
  183.   stupcase := st
  184. end;  { stupcase }
  185.  
  186. procedure endskip;
  187.  
  188. begin                { underline skipped part of input }
  189.   while errpos < cc do
  190.   begin
  191.     write(psout,'-'); errpos := errpos + 1
  192.   end ;
  193.   skipflag := false
  194. end { endskip } ;
  195.  
  196. procedure nextch;   { read next character; process line end }
  197.  
  198. begin
  199.   if cc = ll
  200.   then begin
  201.     if eof(psin)
  202.     then begin
  203.       writeln(psout);
  204.       writeln(psout,' program incomplete');
  205.       errormsg;
  206.       close(psout); halt;     { abort }
  207.     end ;
  208.     if errpos <> 0
  209.     then begin
  210.       if skipflag then endskip;
  211.       writeln(psout);
  212.       errpos := 0
  213.     end ;
  214.     write(psout,lc:5, '  ');
  215.     ll := 0; cc := 0;
  216.     while not eoln(psin) do
  217.     begin
  218.       if ll > llng-2 then fatal(8);
  219.       read(psin,ch);
  220.       if ch <> chr(10) then begin
  221.         if ord(ch) < 32 then ch := ' ';
  222.         write(psout,ch);
  223.         ll := ll+1;
  224.         line[ll] := ch
  225.       end
  226.     end ;
  227.     ll := ll+1; line[ll] := ' ';
  228.     read(psin,ch); writeln(psout);
  229.   end ;
  230.   cc := cc+1; ch := line[cc];
  231. end { nextch } ;
  232.  
  233. procedure error(n: integer);
  234.  
  235. begin
  236.   if errpos = 0 then write(psout,' ****');
  237.   if cc > errpos
  238.   then begin
  239.     write(psout,' ': cc-errpos, '^', n:2);
  240.     errpos := cc+3; errs := errs + [n]
  241.   end
  242. end { error } ;
  243.  
  244. procedure insymbol;           { reads next symbol }
  245.  
  246. const dotdot = #31;
  247. label  1,2,3 ;
  248. var    i,j,k,e: integer;
  249.        sbuff: string[132];
  250.  
  251.   procedure readscale;
  252.  
  253.   begin
  254.     sbuff := sbuff + 'E';
  255.     nextch;
  256.     if (ch = '+') or (ch = '-')
  257.     then begin
  258.       sbuff := sbuff + ch; nextch;
  259.       end;
  260.     if not ((ch>='0') and (ch<='9'))
  261.     then error(40)
  262.     else repeat
  263.         sbuff := sbuff + ch;
  264.         nextch;
  265.       until not ((ch>='0') and (ch<='9'));
  266.   end;
  267.  
  268. procedure options;
  269.  
  270.   procedure switch(var b: boolean);
  271.  
  272.   begin
  273.     b:=ch='+';
  274.     if not b
  275.     then if not (ch='-')
  276.          then  begin
  277.            error(6);
  278.            while (ch<>'*') and (ch<>',') and (ch<>'}') do nextch;
  279.          end
  280.          else nextch
  281.     else nextch
  282.   end { switch } ;
  283.  
  284.   begin      {options}
  285.     repeat
  286.       nextch;
  287.       if (ch <> '*') and (ch <> '}')
  288.       then begin
  289.         if ((ch='t') or (ch='T'))
  290.         then begin
  291.           nextch; switch(prtables)
  292.         end else if ((ch='s') or (ch='S'))
  293.                  then begin
  294.                    nextch; switch(stackdump)
  295.                  end
  296.       end
  297.     until ch<>','
  298.   end  { options } ;
  299.  
  300. begin    { insymbol }
  301.  
  302. 1: while ch = ' ' do nextch;
  303.  
  304.   if upcase(ch) in ['A'..'Z']
  305.   then begin { identifier or wordsymbol }
  306.       k := 0; id := '          ';
  307.       if ch in ['A'..'Z'] then ch := chr(ord(ch)+32);
  308.       repeat
  309.         if k < alng
  310.         then begin
  311.           k := k+1; id[k] := ch
  312.         end ;
  313.         nextch;
  314.         if ch in ['A'..'Z'] then ch := chr(ord(ch)+32)
  315.       until not ( (ch in ['a'..'z']) or (ch in ['0'..'9'])
  316.                   or (ch='_') );
  317.       i := 1; j:= nkw;    { binary search }
  318.       repeat
  319.         k := (i+j) div 2;
  320.         if id <= key[k] then j := k-1;
  321.         if id >= key[k] then i := k+1
  322.       until i > j;
  323.       if i-1 > j then sy := ksy[k] else sy := ident
  324.     end
  325.  
  326.   else if ch in ['+','-','*','/',')','=',',','[',']',';','&','|','~']
  327.   then begin
  328.       sy := sps[ch]; nextch
  329.     end
  330.  
  331.   else if ch in ['0'..'9']
  332.   then begin { number }
  333.       k := 0; sbuff := '';
  334.       repeat
  335.         sbuff := sbuff + ch;
  336.         k := k+1;
  337.         nextch
  338.       until not ((ch>='0') and (ch<='9'));
  339.       val(sbuff,inum,j);
  340.  
  341.       if ch = '.'
  342.       then begin
  343.         nextch;
  344.         if ch = '.'
  345.         then begin
  346.           ch := dotdot; sy := intcon;
  347.           if j <> 0 then begin
  348.             error(21); inum := 0; k := 0
  349.             end;
  350.           end
  351.         else begin
  352.           sy := realcon; sbuff := sbuff + '.'; e := 0;
  353.           while (ch>='0') and (ch<='9') do
  354.           begin
  355.             e := e-1;
  356.             sbuff := sbuff + ch;
  357.             nextch
  358.           end;
  359.           if e = 0 then error(40);
  360.           if ((ch = 'e') or (ch = 'E')) then readscale;
  361.           val(sbuff,rnum,j);
  362.           if j <> 0 then error(21);
  363.           end
  364.         end
  365.       else if ((ch = 'e') or (ch = 'E'))
  366.         then begin
  367.           sy := realcon;
  368.           readscale;
  369.           val(sbuff,rnum,j);
  370.           if j <> 0 then error(21);
  371.         end
  372.       else begin
  373.         sy := intcon;
  374.         if j <> 0 then begin
  375.           error(21); inum := 0
  376.           end;
  377.         end;
  378.       if upcase(ch) in ['A'..'Z']
  379.       then error(40);
  380.     end
  381.  
  382.   else case ch of
  383.  
  384. ':':
  385.     begin
  386.       nextch;
  387.       if ch = '='
  388.       then begin
  389.         sy := becomes; nextch
  390.       end  else sy := colon
  391.     end;
  392.  
  393. '<':
  394.     begin
  395.       nextch;
  396.       if ch = '='
  397.       then begin
  398.         sy := leq; nextch
  399.       end else
  400.         if ch = '>'
  401.         then begin
  402.           sy := neq; nextch
  403.         end else sy := lss
  404.     end;
  405.  
  406. '>':
  407.     begin
  408.       nextch;
  409.       if ch = '='
  410.       then begin
  411.         sy := geq; nextch
  412.       end else sy := gtr
  413.     end;
  414.  
  415. '.':
  416.     begin
  417.       nextch;
  418.       if ch = '.'
  419.       then begin
  420.         sy := twodots; nextch
  421.       end else sy := period
  422.     end;
  423.  
  424. dotdot:
  425.     begin
  426.       sy := twodots; nextch
  427.     end;
  428.  
  429. '''':
  430.     begin
  431.       sbuff := '';
  432.  2:   nextch;
  433.       if ch = ''''
  434.       then  begin
  435.         nextch;
  436.         if ch <> '''' then goto 3
  437.       end ;
  438.       if length(sbuff) < 132
  439.       then sbuff := sbuff + ch
  440.       else error(38);
  441.       if cc = 1
  442.       then error(38)  { end of line }
  443.       else goto 2;
  444.  
  445.  3:   if length(sbuff) = 1
  446.       then begin
  447.         sy := charcon; inum := ord(sbuff[1])
  448.       end else begin
  449.         sy := stringcon;
  450.         sleng := length(sbuff);
  451.         if sleng=0
  452.         then spnt := ptr(nul,0)
  453.         else begin
  454.           getmem(spnt,((sleng+3) div 16 +1)*16);
  455.           k := seg(spnt^);
  456.           memw[k:0] := sleng;
  457.           memw[k:2] := 0;
  458.           move(sbuff[1],mem[k:4],sleng);
  459.         end;
  460.       end
  461.     end;
  462.  
  463. '(':
  464.     begin
  465.       nextch;
  466.       if ch <> '*'
  467.       then sy := lparent
  468.       else begin { comment }
  469.         nextch;
  470.         if ch='$' then options;
  471.         repeat
  472.           while ch <>  '*' do nextch;
  473.           nextch
  474.         until ch = ')';
  475.         nextch; goto 1
  476.       end
  477.     end;
  478.  
  479. '{':
  480.     begin { comment }
  481.       nextch;
  482.       if ch='$' then options;
  483.       while ch <> '}' do nextch;
  484.       nextch; goto 1
  485.     end;
  486.  
  487. '$':
  488.     begin { hex }
  489.       nextch;
  490.       k := 0; sbuff := '$';
  491.       while upcase(ch) in ['0'..'9','A'..'F'] do begin
  492.         k := k+1;
  493.         sbuff := sbuff + ch;
  494.         nextch; end;
  495.       if (k = 0) or (upcase(ch) in ['G'..'Z']) then error(40)
  496.       else if k > 4 then error(21)
  497.       else val(sbuff,inum,j);
  498.       sy := intcon;
  499.     end;
  500.  
  501.   else nextch; error(24); goto 1
  502.  
  503.   end {case}
  504. end {insymbol } ;
  505.  
  506. procedure enter(x0: alfa;  x1: object;
  507.                 x2: types; x3: integer);
  508.  
  509. begin
  510.   t := t+1;         { enter standard identifier }
  511.   with tab[t] do
  512.   begin
  513.     name := x0; link := t-1; obj := x1;
  514.     typ := x2; ref := 0; normal := true;
  515.     lev := 0; adr := x3
  516.   end
  517. end { enter } ;
  518.  
  519. procedure enterarray(tp: types; l,h: integer);
  520.  
  521. begin
  522.   if l > h then error(27);
  523.   if (abs(l)>xmax) or (abs(h)>xmax)
  524.   then begin
  525.     error(27); l := 0; h := 0;
  526.   end ;
  527.   if a = amax
  528.   then fatal(4)
  529.   else begin
  530.     a := a+1;
  531.     with atab[a] do
  532.     begin
  533.       inxtyp := tp; low := l; high := h
  534.     end
  535.   end
  536. end {enterarray } ;
  537.  
  538. procedure enterblock;
  539.  
  540. begin
  541.   if b = bmax
  542.   then fatal(2)
  543.   else begin
  544.     b := b+1; btab[b].last := 0; btab[b].lastpar := 0
  545.   end
  546. end { enterblock } ;
  547.  
  548. procedure enterreal(x: real);
  549.  
  550. begin
  551.   if c2 = c2max-1
  552.   then fatal(3)
  553.   else begin
  554.     rconst[c2+1] := x; c1 := 1;
  555.     while rconst[c1] <> x do c1 := c1+1;
  556.     if c1 > c2 then c2 := c1
  557.   end
  558. end { enterreal } ;
  559.  
  560. procedure emit(fct: integer);
  561.  
  562. begin
  563.   if lc = cmax then fatal(6);
  564.   code[lc].f := fct; lc := lc+1
  565. end { emit } ;
  566.  
  567. procedure emit1(fct,b: integer);
  568.  
  569. begin
  570.   if lc = cmax then fatal(6);
  571.   with code[lc] do
  572.   begin
  573.     f := fct; y := b
  574.   end ;
  575.   lc := lc+1
  576. end { emit1 } ;
  577.  
  578. procedure emit2(fct,a,b: integer);
  579.  
  580. begin
  581.   if lc = cmax then fatal(6);
  582.   with code[lc] do
  583.   begin
  584.     f := fct; x := a; y := b
  585.   end ;
  586.   lc := lc+1
  587. end { emit2 } ;
  588.  
  589. procedure printtables;
  590.  
  591. var    i:integer;
  592.        o: order;
  593.  
  594. begin
  595.   writeln(psout); writeln(psout); writeln(psout);
  596.   writeln(psout,'   identifiers link  obj  typ  ref  nrm  lev  adr');
  597.   writeln(psout);
  598.   for i := btab[1].last to t do
  599.     with tab[i] do
  600.       writeln(psout,i,' ',name,link:5, ord(obj):5, ord(typ):5, ref:5,
  601.               ord(normal):5, lev:5, adr:5);
  602.  
  603.   writeln(psout); writeln(psout); writeln(psout);
  604.   writeln(psout,'blocks    last lpar psze vsze');
  605.   writeln(psout);
  606.   for i := 1 to b do
  607.     with btab[i] do
  608.       writeln(psout,i:4, last:9, lastpar:5, psize:5, vsize:5);
  609.  
  610.   writeln(psout); writeln(psout); writeln(psout);
  611.   writeln(psout,'arrays    xtyp etyp eref  low high elsz size');
  612.   writeln(psout);
  613.  
  614.   for i := 1 to a do
  615.     with atab[i] do
  616.       writeln(psout,i:4, ord(inxtyp):9, ord(eltyp):5,
  617.               elref:5, low:5, high:5, elsize:5, size:5);
  618.  
  619.   writeln(psout); writeln(psout); writeln(psout);
  620.   writeln(psout,' code:'); writeln(psout);
  621.  
  622.   for i:=0 to lc-1 do
  623.   begin
  624.     write(psout); write(psout,i:5);
  625.     o := code[i]; write(psout,o.f:5);
  626.     if o.f < 100
  627.     then if o.f<4
  628.          then write(psout,o.x:2, o.y:5)
  629.          else write(psout,o.y:7)
  630.     else write(psout,'       ');
  631.     writeln(psout,',')
  632.   end;
  633.   writeln(psout);
  634.   writeln(psout,'Starting address is ',tab[btab[1].last].adr:5)
  635.  
  636. end { printtables };
  637.  
  638. procedure block(fsys: symset; isfun: boolean; level: integer); forward;
  639.  
  640. {$I BLOCK.PAS }
  641.  
  642. {$I INTERPRT.PAS }
  643.  
  644. overlay procedure initialize;
  645.  
  646. procedure setup;
  647.  
  648. begin
  649.   key[ 1] := 'and       '; key[ 2] := 'array     ';
  650.   key[ 3] := 'begin     '; key[ 4] := 'case      ';
  651.   key[ 5] := 'const     '; key[ 6] := 'div       ';
  652.   key[ 7] := 'do        '; key[ 8] := 'downto    ';
  653.   key[ 9] := 'else      '; key[10] := 'end       ';
  654.   key[11] := 'file      '; key[12] := 'for       ';
  655.   key[13] := 'function  '; key[14] := 'goto      ';
  656.   key[15] := 'if        '; key[16] := 'in        ';
  657.   key[17] := 'label     '; key[18] := 'mod       ';
  658.   key[19] := 'nil       '; key[20] := 'not       ';
  659.   key[21] := 'of        '; key[22] := 'or        ';
  660.   key[23] := 'packed    '; key[24] := 'procedure ';
  661.   key[25] := 'program   '; key[26] := 'record    ';
  662.   key[27] := 'repeat    '; key[28] := 'set       ';
  663.   key[29] := 'then      '; key[30] := 'to        ';
  664.   key[31] := 'type      '; key[32] := 'until     ';
  665.   key[33] := 'var       '; key[34] := 'while     ';
  666.   key[35] := 'with      ';
  667.   ksy[ 1] := andsy;        ksy[ 2] := arraysy;
  668.   ksy[ 3] := beginsy;      ksy[ 4] := casesy;
  669.   ksy[ 5] := constsy;      ksy[ 6] := idiv;
  670.   ksy[ 7] := dosy;         ksy[ 8] := downtosy;
  671.   ksy[ 9] := elsesy;       ksy[10] := endsy;
  672.   ksy[11] := filesy;       ksy[12] := forsy;
  673.   ksy[13] := funcsy;       ksy[14] := gotosy;
  674.   ksy[15] := ifsy;         ksy[16] := insy;
  675.   ksy[17] := labelsy;      ksy[18] := imod;
  676.   ksy[19] := nilsy;        ksy[20] := notsy;
  677.   ksy[21] := ofsy;         ksy[22] := orsy;
  678.   ksy[23] := packedsy;     ksy[24] := procsy;
  679.   ksy[25] := programsy;    ksy[26] := recordsy;
  680.   ksy[27] := repeatsy;     ksy[28] := setsy;
  681.   ksy[29] := thensy;       ksy[30] := tosy;
  682.   ksy[31] := typesy;       ksy[32] := untilsy;
  683.   ksy[33] := varsy;        ksy[34] := whilesy;
  684.   ksy[35] := withsy;
  685.  
  686.   sps['+'] := plus;        sps['-'] := minus;
  687.   sps['*'] := times;       sps['/'] := rdiv;
  688.   sps[')'] := rparent;
  689.   sps['='] := eql;         sps[','] := comma;
  690.   sps['['] := lbrack;      sps[']'] := rbrack;
  691.   sps['~'] := notsy;       sps['&'] := andsy;
  692.   sps[';'] := semicolon;   sps['|'] := orsy;
  693. end { setup } ;
  694.  
  695. procedure enterids;
  696.  
  697. begin
  698.   enter('          ', vvariable, notyp, 0);  { sentinel }
  699.   enter('false     ', konstant, bools, 0);
  700.   enter('true      ', konstant, bools, 1);
  701.   enter('maxint    ', konstant, ints, 32767);
  702.   enter('real      ', type1, reals, 1);
  703.   enter('char      ', type1, chars, 1);
  704.   enter('boolean   ', type1, bools, 1);
  705.   enter('integer   ', type1, ints , 1);
  706.   enter('string    ', type1, strngs,1);
  707.   enter('abs       ', funktion, reals,0);
  708.   enter('sqr       ', funktion, reals,2);
  709.   enter('odd       ', funktion, bools,4);
  710.   enter('chr       ', funktion, chars,5);
  711.   enter('ord       ', funktion, ints, 6);
  712.   enter('succ      ', funktion, chars,7);
  713.   enter('pred      ', funktion, chars,8);
  714.   enter('round     ', funktion, ints, 9);
  715.   enter('trunc     ', funktion, ints, 10);
  716.   enter('sin       ', funktion, reals, 11);
  717.   enter('cos       ', funktion, reals, 12);
  718.   enter('exp       ', funktion, reals, 13);
  719.   enter('ln        ', funktion, reals, 14);
  720.   enter('sqrt      ', funktion, reals, 15);
  721.   enter('arctan    ', funktion, reals, 16);
  722.   enter('eof       ', funktion, bools, 17);
  723.   enter('eoln      ', funktion, bools, 18);
  724.   enter('maxavail  ', funktion, ints, 19);
  725.   enter('length    ', funktion, ints, 20);
  726.   enter('copy      ', funktion, strngs, 23);
  727.   enter('pos       ', funktion, ints, 26);
  728.   enter('str       ', funktion, strngs, 33);
  729.   enter('val       ', funktion, ints, 35);
  730.   enter('rval      ', funktion, reals, 37);
  731.   enter('keypressed', funktion, bools, 39);
  732.   enter('random    ', funktion, ints, 40);
  733.   enter('upcase    ', funktion, chars, 42);
  734.   enter('inkey     ', funktion, strngs, 47);
  735.   enter('wherex    ', funktion, ints, 48);
  736.   enter('wherey    ', funktion, ints, 49);   {next: 54}
  737.   enter('read      ', prozedure, notyp, 1);
  738.   enter('readln    ', prozedure, notyp, 2);
  739.   enter('write     ', prozedure, notyp, 3);
  740.   enter('writeln   ', prozedure, notyp, 4);
  741.   enter('halt      ', prozedure, notyp, 5);
  742.   enter('randomize ', prozedure, notyp, 6);
  743.   enter('clrscr    ', prozedure, notyp, 7);
  744.   enter('gotoxy    ', prozedure, notyp, 8);
  745.   enter('textcolor ', prozedure, notyp, 9);
  746.   enter('delay     ', prozedure, notyp, 10);
  747.   enter('textbackgr', prozedure, notyp, 11);
  748.   enter('sound     ', prozedure, notyp, 12);
  749.   enter('nosound   ', prozedure, notyp, 13);
  750.   enter('          ', prozedure, notyp, 0);
  751. end;  { enterids }
  752.  
  753. procedure startup;
  754.  
  755. var
  756.   exists: boolean;
  757.   inf,outf,tempstr: strng;
  758.   commandline: string[127] absolute cseg:$80;
  759.   params: string[127];
  760.   default: byte;
  761.  
  762.   procedure chkinf;
  763.   begin
  764.     inf := stupcase(inf);
  765.     if pos('.',inf) = 0
  766.     then inf := inf + '.PAS';
  767.     assign(psin,inf);
  768.     {$I-} reset(psin) {$I+} ;
  769.     exists := (ioresult = 0);
  770.     if pos(':',inf) = 0
  771.     then inf := chr(default+65) + ':' + inf;
  772.     if not exists
  773.     then writeln('File ', inf, ' not found');
  774.   end;
  775.  
  776.   procedure chkoutf;
  777.   begin
  778.     outf := stupcase(outf);
  779.     assign(psout,outf);
  780.     {$I-} rewrite(psout) {$I+} ;
  781.     exists := (ioresult = 0);
  782.     if pos(':',outf) = 0
  783.     then outf := chr(default+65) + ':' + outf;
  784.     if not exists
  785.     then writeln('can''t open file ',outf);
  786.   end;
  787.  
  788. begin
  789.   inf := ''; outf := ''; params := commandline;
  790.   Inline(
  791.      $B4/$19                    { MOV AH,=$19 }
  792.     /$CD/$21                    { INT =$21   ; determine default drive }
  793.     /$88/$86/default );         { MOV [BP]default,AL }
  794.   while (params <> '') and (params[1] = ' ') do
  795.     delete(params,1,1);
  796.   if params <> ''
  797.   then begin                                       { command line parameters }
  798.     while (params <> '') and (params[1] <> ' ') do begin
  799.       inf := inf + params[1];
  800.       delete(params,1,1); end;
  801.     chkinf;
  802.     if not exists then begin
  803.       commandline := '';
  804.       startup; end
  805.     else begin
  806.       writeln('Source file: ',inf);
  807.       while (params <> '') and (params[1] = ' ') do
  808.         delete(params,1,1);
  809.       if params <> ''
  810.       then while (params <> '') and (params[1] <> ' ') do begin
  811.         outf := outf + params[1];
  812.         delete(params,1,1); end
  813.       else outf := copy(inf,1,pos('.',inf)) + 'LST';
  814.       chkoutf;
  815.       if not exists then begin
  816.         commandline := '';
  817.         startup; end
  818.       else writeln('Listing file: ',outf);
  819.       end;
  820.     end
  821.   else begin                                        { prompt for filenames }
  822.     repeat
  823.       write('  Source file [.PAS] ? '); readln(inf);
  824.       chkinf;
  825.     until exists;
  826.  
  827.     tempstr := copy(inf,1,pos('.',inf)) + 'LST';
  828.     repeat
  829.       repeat
  830.         write('  Listing file [',tempstr,'] ? ');
  831.         readln(outf); outf := stupcase(outf);
  832.       until inf <> outf;
  833.       if outf = '' then outf := tempstr;
  834.       chkoutf;
  835.     until exists;
  836.     end;
  837.   writeln;
  838. end;  { startup }
  839.  
  840. begin    { initialize }
  841.   writeln('                    Facilis   version ', version:4:2);
  842.   writeln;
  843.  
  844.   constbegsys := [plus,minus,intcon,realcon,charcon,stringcon,ident];
  845.   typebegsys  := [ident,arraysy,recordsy];
  846.   blockbegsys := [constsy,typesy,varsy,procsy,funcsy,beginsy];
  847.   facbegsys   := [intcon,realcon,charcon,stringcon,ident,lparent,notsy];
  848.   statbegsys  := [beginsy,ifsy,whilesy,repeatsy,forsy,casesy];
  849.   stantyps    := [notyp,ints,reals,bools,chars,strngs];
  850.  
  851.   assign(prd,'trm:');
  852.   reset(prd);
  853.   assign(prr,'con:');
  854.   rewrite(prr);
  855.  
  856.   getmem(spnt,16);
  857.   if ofs(spnt^) <> 0 then begin
  858.     freemem(spnt,16); getmem(spnt,8);
  859.     getmem(spnt,16); end;
  860.   nul := seg(spnt^);
  861.   memw[nul:0] := 0; memw[nul:2] := 0;
  862.  
  863.   setup;
  864.   startup;
  865.   enterids;
  866. end;  { initialize }
  867.  
  868. procedure block;
  869.  
  870. begin
  871.   blockov(fsys,isfun,level)
  872. end;
  873.  
  874. begin { main }
  875.  
  876.       lc := 0;             ll := 0;
  877.       cc := 0;             ch := ' ';
  878.   errpos := 0;           errs := [];
  879.  
  880.          t := -1;                 a := 0;
  881.          b :=  1;
  882.         c2 :=  0;        display[0] := 1;
  883.   skipflag := false;        prtables:= false;
  884.   stackdump:= false;
  885.  
  886.   initialize;
  887.  
  888.   insymbol;
  889.   if sy <> programsy
  890.   then error(3)
  891.   else begin
  892.     insymbol;
  893.     if sy <> ident
  894.     then error(2)
  895.     else begin
  896.       progname := id;
  897.       insymbol;
  898.       if sy = lparent
  899.       then begin
  900.         repeat
  901.           insymbol;
  902.           if sy<> ident
  903.           then error(2)
  904.           else insymbol
  905.         until sy <> comma;
  906.         if sy = rparent then insymbol else error(4);
  907.       end
  908.     end
  909.   end ;
  910.  
  911.   with btab[1] do
  912.     begin
  913.       last := t; lastpar := 1; psize := 0; vsize := 0;
  914.     end ;
  915.  
  916.   block(blockbegsys+statbegsys, false, 1);
  917.   if sy <> period then error(22);
  918.   emit(131);  { halt }
  919.  
  920.   if prtables then printtables;
  921.   if errs=[]
  922.   then interpret
  923.   else begin
  924.     writeln(psout);
  925.     writeln(psout,'compiled with errors');
  926.     writeln(psout);
  927.     errormsg;
  928.   end;
  929.  
  930.   writeln(psout);
  931.  
  932.   close(psout);
  933.   close(prr)
  934.  
  935. end.